home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / cmpnew / cmpflet.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  11KB  |  308 lines
  1. ;;; CMPFLET  Flet, Labels, and Macrolet.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (si:putprop 'flet 'c1flet 'c1special)
  10. (si:putprop 'flet 'c2flet 'c2)
  11. (si:putprop 'labels 'c1labels 'c1special)
  12. (si:putprop 'labels 'c2labels 'c2)
  13. (si:putprop 'macrolet 'c1macrolet 'c1special)
  14. ;;; c2macrolet is not defined, because MACROLET is replaced by PROGN
  15. ;;; during Pass 1.
  16. (si:putprop 'call-local 'c2call-local 'c2)
  17.  
  18. (defstruct fun
  19.            name            ;;; Function name.
  20.            ref            ;;; Referenced or not.
  21.                        ;;; During Pass1, T or NIL.
  22.                        ;;; During Pass2, the vs-address for the
  23.                        ;;; function closure, or NIL.
  24.            ref-ccb        ;;; Cross closure reference.
  25.                        ;;; During Pass1, T or NIL.
  26.                        ;;; During Pass2, the vs-address for the
  27.                        ;;; function closure, or NIL.
  28.            cfun            ;;; The cfun for the function.
  29.            level        ;;; The level of the function.
  30.            )
  31.  
  32. (defvar *funs* nil)
  33.  
  34. ;;; During Pass 1, *funs* holds a list of fun objects, local macro definitions
  35. ;;; and the symbol 'CB' (Closure Boundary).  'CB' will be pushed on *funs*
  36. ;;; when the compiler begins to process a closure.  A local macro definition
  37. ;;; is a list ( macro-name expansion-function).
  38.  
  39. (defun c1flet (args &aux body ss ts is other-decl info
  40.                          (defs1 nil) (local-funs nil) (closures nil))
  41.   (when (endp args) (too-few-args 'flet 1 0))
  42.   (let ((*funs* *funs*))
  43.        (dolist** (def (car args))
  44.          (cmpck (or (endp def)
  45.                     (not (symbolp (car def)))
  46.                     (endp (cdr def)))
  47.                 "The function definition ~s is illegal." def)
  48.          (let ((fun (make-fun :name (car def) :ref nil :ref-ccb nil)))
  49.               (push fun *funs*)
  50.               (push (list fun (cdr def)) defs1)))
  51.  
  52.        (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
  53.  
  54.        (let ((*vars* *vars*))
  55.             (c1add-globals ss)
  56.             (check-vdecl nil ts is)
  57.             (setq body (c1decl-body other-decl body)))
  58.        (setq info (copy-info (cadr body))))
  59.  
  60.   (dolist* (def (reverse defs1))
  61.     (when (fun-ref-ccb (car def))
  62.           (let ((*vars* (cons 'cb *vars*))
  63.                 (*funs* (cons 'cb *funs*))
  64.                 (*blocks* (cons 'cb *blocks*))
  65.                 (*tags* (cons 'cb *tags*)))
  66.                (let ((lam (c1lambda-expr (cadr def) (fun-name (car def)))))
  67.                     (add-info info (cadr lam))
  68.                     (push (list (car def) lam) closures))))
  69.  
  70.     (when (fun-ref (car def))
  71.           (let ((*blocks* (cons 'lb *blocks*))
  72.                 (*tags* (cons 'lb *tags*))
  73.                 (*vars* (cons 'lb *vars*)))
  74.                (let ((lam (c1lambda-expr (cadr def) (fun-name (car def)))))
  75.                     (add-info info (cadr lam))
  76.                     (push (list (car def) lam) local-funs))))
  77.  
  78.     (when (or (fun-ref (car def)) (fun-ref-ccb (car def)))
  79.           (setf (fun-cfun (car def)) (next-cfun)))
  80.     )
  81.   (if (or local-funs closures)
  82.       (list 'flet info (reverse local-funs) (reverse closures) body)
  83.       body)
  84.   )
  85.  
  86. (defun c2flet (local-funs closures body
  87.                &aux (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*))
  88.  
  89.   (dolist** (def local-funs)
  90.     (setf (fun-level (car def)) *level*)
  91.     (push (list nil *clink* *ccb-vs* (car def) (cadr def)) *local-funs*))
  92.  
  93.   ;;; Setup closures.
  94.   (dolist** (def closures)
  95.     (push (list 'closure
  96.                 (if (null *clink*) nil (cons 0 0))
  97.                 *ccb-vs* (car def) (cadr def))
  98.           *local-funs*)
  99.     (push (car def) *closures*)
  100.     (let ((fun (car def)))
  101.          (declare (object fun))
  102.          (setf (fun-ref fun) (vs-push))
  103.          (wt-nl)
  104.          (wt-vs (fun-ref fun))
  105.          (wt "=make_cclosure(LC" (fun-cfun fun) ",Cnil,") (wt-clink)
  106.          (wt ",Cdata,Cstart,Csize);")
  107.          (wt-nl)
  108.          (wt-vs (fun-ref fun))
  109.          (wt "=MMcons(") (wt-vs (fun-ref fun)) (wt ",") (wt-clink) (wt ");")
  110.          (clink (fun-ref fun))
  111.          (setf (fun-ref-ccb fun) (ccb-vs-push))
  112.          ))
  113.  
  114.   (c2expr body)
  115.   )
  116.  
  117. (defun c1labels (args &aux body ss ts is other-decl info
  118.                       (defs1 nil) (local-funs nil) (closures nil)
  119.                       (fnames nil) (processed-flag nil) (*funs* *funs*))
  120.   (when (endp args) (too-few-args 'labels 1 0))
  121.  
  122.   ;;; bind local-functions
  123.   (dolist** (def (car args))
  124.     (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
  125.            "The local function definition ~s is illegal." def)
  126.     (cmpck (member (car def) fnames)
  127.            "The function ~s was already defined." (car def))
  128.     (push (car def) fnames)
  129.     (let ((fun (make-fun :name (car def) :ref nil :ref-ccb nil)))
  130.          (push fun *funs*)
  131.          (push (list fun nil nil (cdr def)) defs1)))
  132.  
  133.   (setq defs1 (reverse defs1))
  134.  
  135.   ;;; Now DEFS1 holds ( { ( fun-object NIL NIL body ) }* ).
  136.  
  137.   (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
  138.   (let ((*vars* *vars*))
  139.        (c1add-globals ss)
  140.        (check-vdecl nil ts is)
  141.        (setq body (c1decl-body other-decl body)))
  142.   (setq info (copy-info (cadr body)))
  143.  
  144.   (block local-process
  145.     (loop
  146.      (setq processed-flag nil)
  147.      (dolist** (def defs1)
  148.        (when (and (fun-ref (car def))        ;;; referred locally and
  149.                   (null (cadr def)))        ;;; not processed yet
  150.          (setq processed-flag t)
  151.          (setf (cadr def) t)
  152.          (let ((*blocks* (cons 'lb *blocks*))
  153.                (*tags* (cons 'lb *tags*))
  154.                (*vars* (cons 'lb *vars*)))
  155.               (let ((lam (c1lambda-expr (cadddr def) (fun-name (car def)))))
  156.                    (add-info info (cadr lam))
  157.                    (push (list (car def) lam) local-funs)))))
  158.      (unless processed-flag (return-from local-process))
  159.      )) ;;; end local process
  160.  
  161.   (block closure-process
  162.     (loop
  163.      (setq processed-flag nil)
  164.      (dolist** (def defs1)
  165.        (when (and (fun-ref-ccb (car def))    ; referred across closure
  166.                   (null (caddr def)))        ; and not processed
  167.          (setq processed-flag t)
  168.          (setf (caddr def) t)
  169.          (let ((*vars* (cons 'cb *vars*))
  170.                (*funs* (cons 'cb *funs*))
  171.                (*blocks* (cons 'cb *blocks*))
  172.                (*tags* (cons 'cb *tags*)))
  173.               (let ((lam (c1lambda-expr (cadddr def) (fun-name (car def)))))
  174.                    (add-info info (cadr lam))
  175.                    (push (list (car def) lam) closures))))
  176.        )
  177.      (unless processed-flag (return-from closure-process))
  178.      )) ;;; end closure process
  179.  
  180.   (dolist** (def defs1)
  181.     (when (or (fun-ref (car def)) (fun-ref-ccb (car def)))
  182.           (setf (fun-cfun (car def)) (next-cfun))))
  183.  
  184.   (if (or local-funs closures)
  185.       (list 'labels info (reverse local-funs) (reverse closures) body)
  186.       body)
  187.   )
  188.  
  189. (defun c2labels (local-funs closures body &aux (*vs* *vs*) (*clink* *clink*))
  190.  
  191.   ;;; Prepare for cross-referencing closures.
  192.   (dolist** (def closures)
  193.     (let ((fun (car def)))
  194.          (declare (object fun))
  195.          (setf (fun-ref fun) (vs-push))
  196.          (wt-nl)
  197.          (wt-vs (fun-ref fun))
  198.          (wt "=MMcons(Cnil,") (wt-clink) (wt ");")
  199.          (clink (fun-ref fun))
  200.          (setf (fun-ref-ccb fun) (ccb-vs-push))
  201.     ))
  202.  
  203.   (dolist** (def local-funs)
  204.     (setf (fun-level (car def)) *level*)
  205.     (push (list nil *clink* *ccb-vs* (car def) (cadr def)) *local-funs*))
  206.  
  207.   ;;; Then make closures.
  208.   (dolist** (def closures)
  209.     (push (list 'closure (if (null *clink*) nil (cons 0 0))
  210.                 *ccb-vs* (car def) (cadr def))
  211.           *local-funs*)
  212.     (push (car def) *closures*)
  213.     (wt-nl)
  214.     (wt-vs* (fun-ref (car def)))
  215.     (wt "=make_cclosure(LC" (fun-cfun (car def)) ",Cnil,") (wt-clink)
  216.     (wt ",Cdata,Cstart,Csize);")
  217.     )
  218.  
  219.   ;;; now the body of flet
  220.  
  221.   (c2expr body)
  222.   )
  223.  
  224. (defun c1macrolet (args &aux body ss ts is other-decl
  225.                         (*funs* *funs*) (*vars* *vars*))
  226.   (when (endp args) (too-few-args 'macrolet 1 0))
  227.   (dolist** (def (car args))
  228.     (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
  229.            "The macro definition ~s is illegal." def)
  230.     (push (list (car def)
  231.                 (caddr (si:defmacro* (car def) (cadr def) (cddr def))))
  232.           *funs*))
  233.   (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
  234.   (c1add-globals ss)
  235.   (check-vdecl nil ts is)
  236.   (c1decl-body other-decl body)
  237.   )
  238.  
  239. (defun c1local-fun (fname &aux (ccb nil))
  240.   (declare (object ccb))
  241.   (dolist* (fun *funs* nil)
  242.     (cond ((eq fun 'CB) (setq ccb t))
  243.           ((consp fun)
  244.            (when (eq (car fun) fname) (return (cadr fun))))
  245.           ((eq (fun-name fun) fname)
  246.            (if ccb
  247.                (setf (fun-ref-ccb fun) t)
  248.                (setf (fun-ref fun) t))
  249.            (return (list 'call-local *info* fun ccb)))))
  250.   )
  251.  
  252. (defun sch-local-fun (fname)
  253.   ;;; Returns fun-ob for the local function (not locat macro) named FNAME,
  254.   ;;; if any.  Otherwise, returns FNAME itself.
  255.   (dolist* (fun *funs* fname)
  256.     (when (and (not (eq fun 'CB))
  257.                (not (consp fun))
  258.                (eq (fun-name fun) fname))
  259.           (return fun)))
  260.   )
  261.  
  262. (defun c1local-closure (fname &aux (ccb nil))
  263.   (declare (object ccb))
  264.   ;;; Called only from C1FUNCTION.
  265.   (dolist* (fun *funs* nil)
  266.     (cond ((eq fun 'CB) (setq ccb t))
  267.           ((consp fun)
  268.            (when (eq (car fun) fname) (return (cadr fun))))
  269.           ((eq (fun-name fun) fname)
  270.            (setf (fun-ref-ccb fun) t)
  271.            (return (list 'call-local *info* fun ccb)))))
  272.   )
  273.  
  274. (defun c2call-local (fd args &aux (*vs* *vs*))
  275.   ;;; FD is a list ( fun-object ccb ).
  276.   (cond
  277.    ((cadr fd)
  278.     (push-args args)
  279.     (wt-nl "cclosure_call(") (wt-ccb-vs (fun-ref-ccb (car fd))) (wt ");"))
  280.    ((and (listp args)
  281.          *do-tail-recursion*
  282.          *tail-recursion-info*
  283.          (eq (car *tail-recursion-info*) (car fd))
  284.          (eq *exit* 'RETURN)
  285.          (tail-recursion-possible)
  286.          (= (length args) (length (cdr *tail-recursion-info*))))
  287.     (let* ((*value-to-go* 'trash)
  288.            (*exit* (next-label))
  289.            (*unwind-exit* (cons *exit* *unwind-exit*)))
  290.           (c2psetq (mapcar #'(lambda (v) (list v nil))
  291.                            (cdr *tail-recursion-info*))
  292.                    args)
  293.           (wt-label *exit*))
  294.     (unwind-no-exit 'tail-recursion-mark)
  295.     (wt-nl "goto TTL;")
  296.     (cmpnote "Tail-recursive call of ~s was replaced by iteration."
  297.              (fun-name (car fd))))
  298.    (t (push-args args)
  299.       (wt-nl "L" (fun-cfun (car fd)) "(")
  300.       (dotimes** (n (fun-level (car fd))) (wt "base" n ","))
  301.       (wt "base")
  302.       (unless (= (fun-level (car fd)) *level*) (wt (1- *level*)))
  303.       (wt ");")
  304.       (base-used)))
  305.   (unwind-exit 'fun-val)
  306.   )
  307.  
  308.